home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / p063b9s.zip / UNIT / PINGANSI.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-20  |  17KB  |  520 lines

  1. {$Define TurboPower}{ use Turbo Power Professional }
  2. {$Define Music} { implement 'ansi'-music }
  3. {$Define BBS} { enable support for bbs/communication usage }
  4. {$Define Small} { enable i/o driver }
  5. (*
  6.      PingAnsi v 1.33 (c) CopyRight 1990 P.H.Rankin Hansen.
  7.  
  8.      This unit provides partial Ansi emulation for Turbo Pascal versions
  9.      5.x and higher.  (version 4 does  not implement  procedural types).
  10.      Some routines may be handled in a non-standard way.
  11.  
  12.      Released in Denmark on August 23rd 1990.
  13.  
  14.      By  using  this  material  You  assume  FULL responsibility for ANY
  15.      consequences-direct  or   indirect-thereof.
  16.      Any dispute regarding this material shall be setteled by Danish law
  17.      and in a Danish Court.
  18.  
  19.      (Sigh!)
  20.  
  21.      This  source may  NOT be  used by  Lawyers, Politicians or  persons
  22.      engaged  in any  other form  of terrorism.  Otherwise the  usage is
  23.      free.
  24.  
  25.      This source may be freely distributed as long as no fee is charged.
  26.  
  27.      Please direct any comments,  corrections, modifications via netmail
  28.      to:
  29.  
  30.                       Ping Hansen-FidoNet 2:231/62.58
  31.  
  32. *)
  33.  
  34. Unit PingAnsi;
  35.   {-}
  36. Interface
  37.  
  38. Uses
  39.   Use32,
  40.   {$IFDEF TurboPower}
  41.   { Turbo Power units. The standard CRT unit will not work in a TSR }
  42.   OpCrt, OpString;
  43.   {$ELSE}
  44.   { Replacements for Turbo Power units for those unfortunates who doesn't    }
  45.   { have them. It is recommended to buy the Turbo Power toolboxes partly     }
  46.   { because the standard crt unit doesn't stand up too well in a TSR/        }
  47.   { Multitasking environment and partly because they, IMHO, generally make   }
  48.   { life easier for pascal programmers.                                      }
  49.   Crt, PoorMan;
  50.   {$ENDIF}
  51.  
  52. Var
  53.   Wrap                : Boolean;  { True if Cursor should wrap }
  54.   ReportedX,
  55.   ReportedY           : Word;     { X,Y reported }
  56.  
  57.   { hook for implementing Your own Device Status Report procedure }
  58.   ReplyHook           : Procedure(St : String);
  59.  
  60.   { hook for implementing Your own KeyBoard ReAssignment }
  61.   KeyHook             : Procedure(St : String);
  62.  
  63.   { Hook for handling control chars i.e. Ch<Space }
  64.   WriteHook           : Procedure(Ch : Char);
  65.  
  66.   {$IFNDEF Small}
  67.   {$IFDEF BBS}
  68.  
  69.   { Hook for handling simultaneous writes to ComPort and Screen }
  70.   BBsHook       : Procedure (Ch : Char);
  71.  
  72.   {$ENDIF}
  73.   {$ENDIF}
  74.  
  75.   {$IFDEF Music}
  76.  
  77.   { Hook for handling music }
  78.   PlayHook  : Procedure(St : String);
  79.  
  80.   {$ENDIF}
  81.  
  82. Procedure ClearAnsiState;
  83. Function In_Ansi    : Boolean;    { True if a sequence is pending }
  84. Procedure AnsiWrite(Ch : Char);
  85.  
  86.   {$IFNDEF Small}
  87.  
  88. Procedure AssignAnsi(Var f : Text); { use like AssignCrt }
  89.  
  90.   {$ENDIF}
  91.  
  92. Implementation
  93.  
  94. Type
  95.   States             =(Waiting, Bracket, Get_Args, Get_Param, Eat_Semi,
  96.                          Get_String, In_Param, Get_Music);
  97. Const
  98.   St                  : String='';
  99.   ParamArr            : Array[1..10] Of Word=(0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
  100.   Params              : Word=0; { number of parameters }
  101.   NextState           : States=Waiting; { next state for the parser }
  102.   Reverse             : Boolean=False; { true if text attributes are reversed }
  103.  
  104. Var
  105.   Quote               : Char;
  106.   SavedX, SavedY      : Word;
  107.  
  108.   Procedure ClearAnsiState;
  109.   BEGIN
  110.     NextState:=Waiting;
  111.   END;
  112.  
  113.   Function In_Ansi    : Boolean;  { True if a sequence is pending }
  114.   Begin
  115.     In_Ansi:=(NextState<>Waiting) And (NextState<>Bracket);
  116.   End {In_Ansi} ;
  117.  
  118.  
  119.   Procedure Report(St : String); far;
  120.   Begin
  121.     StuffString(St);
  122.   End;
  123.  
  124.   Procedure WriteChar(Ch : Char); far;
  125.   Begin
  126.     Case Ch Of
  127.       #7 : Begin
  128. {$IFDEF OS2}
  129.              PlaySound(500,50);
  130. {$ELSE}
  131.              NoSound;
  132.              Sound(500);
  133.              Delay(50);
  134.              NoSound;
  135.              Delay(50);
  136. {$ENDIF}
  137.            End;
  138.       #8 : If (WhereX>1) Then Write(#8' '#8);
  139.       #9 : If (WhereX<71) Then
  140.            Repeat
  141.              GotoXy(WhereX+1, Wherey);
  142.            Until (WhereX Mod 8=1);
  143.       Else
  144.         Write(Ch);
  145.     End {Case} ;
  146.   End {WriteChar} ;
  147.  
  148.   Procedure Dummy(St : String); far;
  149.   Begin
  150.   End;
  151.  
  152.   Procedure AnsiWrite(Ch : Char);
  153.  
  154.   Var
  155.     i                   : Word;
  156.  
  157.   Label Command;
  158.  
  159.   Begin
  160.     If Ch=#27 Then
  161.     Begin
  162.       NextState:=Bracket;
  163.       Exit;
  164.     End;
  165.     Case NextState Of
  166.       Waiting : If (Ch>' ') Then Write(Ch) Else WriteHook(Ch);
  167.       Bracket :
  168.         Begin
  169.           If Ch<>'[' Then
  170.           Begin
  171.             NextState:=Waiting;
  172.             If (Ch>' ') Then Write(Ch) Else WriteHook(Ch);
  173.             Exit;
  174.           End;
  175.           St:='';
  176.           Params:=1;
  177.           FillChar(ParamArr, 10, 0);
  178.           NextState:=Get_Args;
  179.         End;
  180.       Get_Args,
  181.       Get_Param,
  182.       Eat_Semi : Begin
  183.                   {$IFNDEF Music}
  184.                   If (NextState=Get_Args) And ((Ch='=') Or (Ch='?')) Then
  185.                   Begin
  186.                     NextState:=Get_Param;
  187.                     Exit;
  188.                   End;
  189.                   {$ELSE}
  190.                   If (NextState=Get_Args) Then
  191.                     Case Ch Of
  192.                       '=', '?' : Begin
  193.                                    NextState:=Get_Param;
  194.                                    Exit;
  195.                                  End;
  196.            'M' : Begin
  197.                    NextState:=Get_Music;
  198.                    Exit;
  199.                  End;
  200.             End {Case} ;
  201.           {$ENDIF}
  202.           If (NextState=Eat_Semi) And (Ch=';') Then
  203.           Begin
  204.             If Params<10 Then Inc(Params);
  205.             NextState:=Get_Param;
  206.             Exit;
  207.           End;
  208.           Case Ch Of
  209.             '0'..'9' : Begin
  210.                          ParamArr[Params]:=Ord(Ch)-Ord('0');
  211.                          NextState:=In_Param;
  212.                        End;
  213.                  ';' : Begin
  214.                          If Params<10 Then Inc(Params);
  215.                          NextState:=Get_Param;
  216.                        End;
  217.            '"', '''' : Begin
  218.                          Quote:=Ch;
  219.                          St:=St+Ch;
  220.                          NextState:=Get_String;
  221.                        End;
  222.             Else
  223.               GoTo Command;
  224.           End {Case Ch} ;
  225.         End;
  226.       Get_String :
  227.         Begin
  228.           St:=St+Ch;
  229.           If Ch<>Quote Then NextState:=Get_String Else NextState:=Eat_Semi;
  230.         End;
  231.       In_Param :                  { last char was a digit }
  232.         Begin
  233.           { looking for more digits, a semicolon, or a command char }
  234.           Case Ch Of
  235.             '0'..'9' : Begin
  236.                 ParamArr[Params]:=ParamArr[Params] * 10+Ord(Ch)-Ord('0');
  237.                 NextState:=In_Param;
  238.                 Exit;
  239.               End;
  240.             ';' :
  241.               Begin
  242.                 If Params<10 Then Inc(Params);
  243.                 NextState:=Eat_Semi;
  244.                 Exit;
  245.               End;
  246.           End {Case Ch} ;
  247. Command:
  248.           NextState:=Waiting;
  249.           Case Ch Of
  250.             { Note: the order of commands is optimized for execution speed }
  251.             'm' :                 {sgr}
  252.               Begin
  253.                 For i:=1 To Params Do
  254.                 Begin
  255.                   If Reverse Then TextAttr:=TextAttr Shr 4+TextAttr Shl 4;
  256.                   Case ParamArr[i] Of
  257.                     0 :
  258.                       Begin
  259.                         Reverse:=False;
  260.                         TextAttr:=7;
  261.                       End;
  262.                     1 : TextAttr:=TextAttr Or $08;
  263.                  2,22 : TextAttr:=TextAttr And $F7;
  264.                  4,34 : TextAttr:=TextAttr And $F8 Or $01;
  265.                     5 : TextAttr:=TextAttr Or $80;
  266.                     7 : If Not Reverse Then
  267.                         Begin
  268.                       {
  269.                       TextAttr:=TextAttr shr 4+TextAttr shl 4;
  270.                       }
  271.                           Reverse:=True;
  272.                         End;
  273.                     24 : TextAttr:=TextAttr And $F8 Or $04;
  274.                     25 : TextAttr:=TextAttr And $7F;
  275.                     27 : If Reverse Then
  276.                          Begin
  277.                            Reverse:=False;
  278.                       {
  279.                       TextAttr:=TextAttr shr 4+TextAttr shl 4;
  280.                       }
  281.                          End;
  282.                     30 : TextAttr:=TextAttr And $F8;
  283.                     31 : TextAttr:=TextAttr And $F8 Or $04;
  284.                     32 : TextAttr:=TextAttr And $F8 Or $02;
  285.                     33 : TextAttr:=TextAttr And $F8 Or $06;
  286.                     35 : TextAttr:=TextAttr And $F8 Or $05;
  287.                     36 : TextAttr:=TextAttr And $F8 Or $03;
  288.                     37 : TextAttr:=TextAttr And $F8 Or $07;
  289.                     40 : TextAttr:=TextAttr And $8F;
  290.                     41 : TextAttr:=TextAttr And $8F Or $40;
  291.                     42 : TextAttr:=TextAttr And $8F Or $20;
  292.                     43 : TextAttr:=TextAttr And $8F Or $60;
  293.                     44 : TextAttr:=TextAttr And $8F Or $10;
  294.                     45 : TextAttr:=TextAttr And $8F Or $50;
  295.                     46 : TextAttr:=TextAttr And $8F Or $30;
  296.                     47 : TextAttr:=TextAttr And $8F Or $70;
  297.                   End {Case} ;
  298.                   { fixup for reverse }
  299.                   If Reverse Then TextAttr:=TextAttr Shr 4+TextAttr Shl 4;
  300.                 End;
  301.               End;
  302.             'A' :                 {cuu}
  303.               Begin
  304.                 If ParamArr[1]=0 Then ParamArr[1]:=1;
  305.                 If (Wherey-ParamArr[1]>=1) Then GotoXy(WhereX,Wherey-ParamArr[1])
  306.                                            Else GotoXy(WhereX, 1);
  307.               End;
  308.             'B' :                 {cud}
  309.               Begin
  310.                 If ParamArr[1]=0 Then ParamArr[1]:=1;
  311.                 If (Wherey+ParamArr[1]<=Hi(WindMax)-Hi(WindMin)+1) Then GotoXy(WhereX, Wherey+ParamArr[1])
  312.                                                                    Else GotoXy(WhereX, Hi(WindMax)-Hi(WindMin)+1);
  313.               End;
  314.             'C' :                 {cuf}
  315.               Begin
  316.                 If ParamArr[1]=0 Then ParamArr[1]:=1;
  317.                 If (WhereX+ParamArr[1]<=Lo(WindMax)-Lo(WindMin)+1) Then GotoXy(WhereX+ParamArr[1], Wherey)
  318.                                                                    Else GotoXy(Lo(WindMax)-Lo(WindMin)+1, Wherey);
  319.               End;
  320.             'D' :                 {cub}
  321.               Begin
  322.                 If (ParamArr[1]=0) Then ParamArr[1]:=1;
  323.                 If (WhereX-ParamArr[1]>=1) Then GotoXy(WhereX-ParamArr[1], Wherey)
  324.                                              Else GotoXy(1, Wherey);
  325.               End;
  326.             'H', 'f' :            {cup,hvp}
  327.               Begin
  328.                 If (ParamArr[1]=0) Then ParamArr[1]:=1;
  329.                 If (ParamArr[2]=0) Then ParamArr[2]:=1;
  330.  
  331.                 If (ParamArr[2]>Lo(WindMax)+1) then ParamArr[2]:=Lo(WindMax)-Lo(WindMin)+1;
  332.                 If (ParamArr[1]>Hi(WindMax)+1)
  333.                   then ParamArr[1]:=Hi(WindMax)-Hi(WindMin)+1;
  334.                 GotoXy(ParamArr[2], ParamArr[1]) ;
  335.               End;
  336.             'J' :                 {EID}
  337.               Case ParamArr[1] Of
  338.                 2 : ClrScr;
  339.                 0 :               {ClrEos}
  340.                   Begin
  341.                     ClrEol;
  342.                     ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+Wherey+1,
  343.                                      Lo(WindMax)+1, Hi(WindMax)+1, 0);
  344.                   End;
  345.                 1 :               {Clear from beginning of screen}
  346.                   Begin
  347.                     ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+Wherey,
  348.                                      Lo(WindMin)+WhereX,Hi(WindMin)+Wherey, 0);
  349.                     ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+1,
  350.                                      Lo(WindMax)+1, Hi(WindMin)+Wherey-1, 0);
  351.                   End;
  352.               End {Case} ;
  353.             'K' :                 {eil}
  354.               Case ParamArr[1] Of
  355.                 0 : ClrEol;
  356.                 1 :               { clear from beginning of line to cursor }
  357.                   ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+Wherey,
  358.                                    Lo(WindMin)+WhereX-1,
  359.                                    Hi(WindMin)+Wherey, 0);
  360.                 2 :               { clear entire line }
  361.                   ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+Wherey,
  362.                                    Lo(WindMax)+1,
  363.                                    Hi(WindMin)+Wherey, 0);
  364.               End {Case ParamArr} ;
  365.             'L' : {il } For i:=1 To ParamArr[1] Do InsLine; { must not move cursor }
  366.             'M' : {d_l} For i:=1 To ParamArr[1] Do DelLine; { must not move cursor }
  367.             'P' :                 {dc }
  368.               Begin
  369.               End;
  370.             'R' :                 {cpr}
  371.               Begin
  372.                 ReportedY:=ParamArr[1];
  373.                 ReportedX:=ParamArr[2];
  374.               End;
  375.             '@' :                 {ic}
  376.               Begin
  377.                 { insert blank chars }
  378.               End;
  379.             'h', 'l' :            {sm/rm}
  380.               Case ParamArr[1] Of
  381.                 0 : {TextMode(BW40)};
  382.                 1 : {TextMode(CO40)};
  383.                 2 : {TextMode(BW80)};
  384.                 3 : {TextMode(CO80)};
  385.                 4 : {GraphMode(320x200 col)} ;
  386.                 5 : {GraphMode(320x200 BW)} ;
  387.                 6 : {GraphMode(640x200 BW)} ;
  388.                 7 : Wrap:=Ch='h';
  389.               End {case} ;
  390.             'n' :                 {dsr}
  391.               If (ParamArr[1]=6) Then
  392.                 ReplyHook(#27'['+Long2str(Wherey)+';' +
  393.                           Long2str(WhereX)+'R');
  394.             's' :                 {scp}
  395.               Begin
  396.                 SavedX:=WhereX;
  397.                 SavedY:=Wherey;
  398.               End;
  399.             'u' : {rcp} GotoXy(SavedX, SavedY);
  400.             'p' :                 {keyboard reassignment}
  401.               KeyHook(St);
  402.             Else
  403.               Begin
  404.                 If (Ch>' ') Then Write(Ch)
  405.                 Else WriteHook(Ch);
  406.                 Exit;
  407.               End;
  408.           End {Case Ch} ;
  409.         End;
  410.       {$IFDEF Music}
  411.       Get_Music :
  412.         Begin
  413.           If Ch<>#3 Then St:=St+Ch Else
  414.           Begin
  415.             NextState:=Waiting;
  416.             PlayHook(St);
  417.           End;
  418.         End;
  419.       {$ENDIF}
  420.     End {Case NextState} ;
  421.   End {AnsiWrite} ;
  422.  
  423.   {$IFNDEF Small}
  424.  
  425.  
  426.   Function Nothing(Var f : TextRec) : Integer; far;
  427.   Begin
  428.     Nothing:=0;
  429.   End {Nothing} ;
  430.  
  431.   Procedure Null(Ch : Char); far;
  432.   Begin
  433.     {}
  434.   End {Null} ;
  435.  
  436.   Function DevOutput(Var f : TextRec) : Integer; far;
  437.   Var
  438.     i                   : Integer;
  439.   Begin
  440.     With f Do
  441.     Begin
  442.       { f.BufPos contains the number of chars in the buffer }
  443.       { f.BufPtr^ is your buffer                            }
  444.       { Any variable conversion done by writeln is already  }
  445.       { done by now.                                        }
  446.       i:=0;
  447.       While i<BufPos Do
  448.       Begin
  449.         AnsiWrite(BufPtr^[i]);
  450.         {$IFDEF BBS}
  451.         BBSHook(BufPtr^[i]);
  452.         {$ENDIF}
  453.         Inc(i);
  454.       End;
  455.       BufPos:=0;
  456.     End;
  457.     DevOutput:=0;               { return IOResult Error codes here }
  458.   End {DevOutput} ;
  459.  
  460.   Function DevOpen(Var f : TextRec) : Integer; far;
  461.   Begin
  462.     With f Do
  463.     Begin
  464.       If Mode=FmInput Then
  465.       Begin
  466.         InOutFunc:=@Nothing;
  467.         FlushFunc:=@Nothing;
  468.       End
  469.       Else
  470.       Begin
  471.         Mode:=FmOutput;         { in case it was FmInOut }
  472.         InOutFunc:=@DevOutput;
  473.         FlushFunc:=@DevOutput;
  474.       End;
  475.       CloseFunc:=@Nothing;
  476.     End;
  477.     DevOpen:=0;                 { return IOResult error codes here }
  478.   End {DevOpen} ;
  479.  
  480.   Procedure AssignAnsi(Var f : Text);
  481.   Begin
  482.     FillChar(f, SizeOf(f), #0);   { init file var }
  483.     With TextRec(f) Do
  484.     Begin
  485.       Handle:=$ffff;
  486.       Mode:=FmClosed;
  487.       BufSize:=SizeOf(Buffer);
  488.       BufPtr:=@Buffer;
  489.       OpenFunc:=@DevOpen;
  490.       Name[0]:=#0;
  491.     End;
  492.   End {AssignAnsi} ;
  493.   {$ENDIF}
  494.  
  495. Begin
  496.  
  497.   {$IFNDEF Small}
  498.  
  499.   AssignAnsi(Ansi);               { set up the variable }
  500.   Rewrite(Ansi);                  { open it for output  }
  501.  
  502.   {$IFDEF BBS}
  503.  
  504.     BBsHook:=Null;
  505.  
  506.   {$ENDIF}
  507.   {$ENDIF}
  508.  
  509.   Wrap:=True;
  510.   ReplyHook:=Report;
  511.   KeyHook:=Dummy;
  512.   WriteHook:=WriteChar;
  513.  
  514.   {$IFDEF Music}
  515.  
  516.   PlayHook:=Dummy; { point play into the great music heaven }
  517.  
  518.   {$ENDIF}
  519. End.
  520.